home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / newports.scm < prev    next >
Text File  |  1995-10-28  |  13KB  |  413 lines
  1. ;;; A Unix file port system to completely replace S48 file ports.
  2. ;;; We use S48 extensible ports.
  3. ;;; Copyright (c) 1993 by Olin Shivers.
  4.  
  5. (define-record fdport-data
  6.   fd        ; Unix file descriptor - integer.
  7.   (closed? #f)    ; Is port closed.
  8.   (peek-char #f)
  9.   (revealed 0)        ; REVEALED & OLD-REVEALED are for keeping
  10.   (old-revealed 0))    ; track of whether the FD value has escaped.
  11.  
  12. ;;; We could flush the PEEK-CHAR field and use stdio ungetc(), but it
  13. ;;; is only guaranteed for buffered streams. Too bad...
  14.  
  15. (define (make-input-fdport fd)
  16.   (make-extensible-input-port (make-fdport-data fd)
  17.                   input-fdport-methods))
  18.  
  19. (define (make-output-fdport fd)
  20.   (make-extensible-output-port (make-fdport-data fd)
  21.                    output-fdport-methods))
  22.  
  23. (define (fdport? x)
  24.   (cond ((or (and (extensible-input-port?  x)
  25.           (extensible-input-port-local-data  x))
  26.          (and (extensible-output-port? x)
  27.           (extensible-output-port-local-data x)))
  28.      => (lambda (d) (fdport-data? d)))
  29.     (else #f)))
  30.  
  31. ;;; Basic methods
  32. ;;; -------------
  33.  
  34. (define fdport-null-method (lambda (x) x #f))
  35.  
  36. ;;; CLOSE-FDPORT*, FLUSH-FDPORT* defined in syscalls.scm.
  37. ;;; (So you must load that file before loading this file.)
  38.  
  39. (define (fdport*-read-char data)
  40.   (check-arg open-fdport-data? data fdport*-read-char)
  41.   (cond ((fdport-data:peek-char data) =>
  42.      (lambda (char)
  43.        (set-fdport-data:peek-char data #f)
  44.        char))
  45.     (else
  46.      (or (%fdport*-read-char data) eof-object))))
  47.  
  48. (define (fdport*-peek-char data)
  49.   (check-arg open-fdport-data? data fdport*-peek-char)
  50.   (or (fdport-data:peek-char data)
  51.       (cond ((%fdport*-read-char data) =>
  52.          (lambda (char)
  53.            (set-fdport-data:peek-char data char)
  54.            char))
  55.         (else eof-object))))
  56.  
  57. (define (fdport*-char-ready? data)
  58.   (check-arg open-fdport-data? data fdport*-char-ready?)
  59.   (or (fdport-data:peek-char data)
  60.       (%fdport*-char-ready? data)))
  61.  
  62. (define (fdport*-write-char data char)
  63.   (check-arg open-fdport-data? data fdport*-write-char)
  64.   (if (not (fdport-data:closed? data))
  65.       (%fdport*-write-char data char)))
  66.  
  67. (define (fdport*-write-string data string)
  68.   (check-arg open-fdport-data? data fdport*-write-string)
  69.   (generic-write-string string 0 (string-length string) ; from rw.scm
  70.             write-fdport*-substring/errno data))
  71.  
  72. (define input-fdport-methods
  73.   (make-input-port-methods close-fdport*
  74.                fdport*-read-char
  75.                fdport*-peek-char
  76.                fdport*-char-ready?
  77.                fdport-null-method    ; current-column
  78.                fdport-null-method))    ; current-row
  79.                
  80.  
  81. (define output-fdport-methods
  82.   (make-output-port-methods close-fdport*
  83.                 fdport*-write-char
  84.                 fdport*-write-string
  85.                 flush-fdport*        ; force-output
  86.                 fdport-null-method        ; fresh-line
  87.                 fdport-null-method        ; current-column
  88.                 fdport-null-method))    ; current-row
  89.  
  90.  
  91. (define (fdport-data port)
  92.   (let ((d ((cond ((extensible-input-port? port)
  93.            extensible-input-port-local-data)
  94.           ((extensible-output-port? port)
  95.            extensible-output-port-local-data)
  96.           (else (error "Illegal value" port)))
  97.         port)))
  98.     (if (and d (fdport-data? d)) d
  99.     (error "fport closed" port))))
  100.  
  101. (define (%fdport-seek/errno port offset whence)
  102.   (%fdport*-seek/errno (fdport-data port) offset whence))
  103.  
  104. (define (%fdport-tell/errno port)
  105.   (%fdport*-tell/errno (fdport-data port)))
  106.  
  107. (define (%fdport-set-buffering/errno port policy size)
  108.  (%fdport*-set-buffering/errno (fdport-data port) policy size))
  109.  
  110. (define (set-port-buffering port policy . maybe-size)
  111.   (let* ((size (if (pair? maybe-size)
  112.            (if (pair? (cdr maybe-size))
  113.                (error "Too many arguments." set-port-buffering)
  114.                (check-arg (lambda (s) (and (integer? s)
  115.                            (<= 0 s)))
  116.                   (car maybe-size)
  117.                   set-port-buffering))
  118.            -1))
  119.      (policy (if (zero? size) bufpol/none policy))
  120.      (err (%fdport-set-buffering/errno port policy size)))
  121.     (if err (errno-error err set-port-buffering port policy size))))
  122.  
  123.  
  124. ;;; Open & Close
  125. ;;; ------------
  126.  
  127. (define (open-file fname flags . maybe-mode)
  128.   (let* ((fd (apply open-fdes fname flags maybe-mode))
  129.      (access (bitwise-and flags open/access-mask))
  130.      (port ((if (or (= access open/read) (= access open/read+write))
  131.             make-input-fdport
  132.             make-output-fdport)
  133.         fd)))
  134.     (%install-port fd port)
  135.     port))
  136.  
  137. (define (open-input-file fname . maybe-flags)
  138.   (let ((flags (optional-arg maybe-flags 0)))
  139.     (open-file fname (deposit-bit-field flags open/access-mask open/read))))
  140.  
  141. (define (open-output-file fname . rest)
  142.   (let* ((flags (if (pair? rest) (car rest)
  143.             (bitwise-ior open/create open/truncate))) ; default
  144.      (maybe-mode (if (null? rest) '() (cdr rest)))
  145.      (flags (deposit-bit-field flags open/access-mask open/write)))
  146.     (apply open-file fname flags maybe-mode)))
  147.  
  148.  
  149. ;;; All these revealed-count-hacking procs have atomicity problems.
  150. ;;; They need to run uninterrupted.
  151.  
  152. (define (increment-revealed-count port delta)
  153.   (let* ((data (extensible-port-local-data port))
  154.      (count (fdport-data:revealed data)))
  155.     (set-fdport-data:revealed data (+ count delta))))
  156.  
  157. (define (release-port-handle port)
  158.   (check-arg fdport? port port->fdes)
  159.   (let* ((data (extensible-port-local-data port))
  160.      (rev (fdport-data:revealed data)))
  161.     (if (zero? rev)
  162.     (set-fdport-data:old-revealed data
  163.                       (- (fdport-data:old-revealed data) 1))
  164.     (set-fdport-data:revealed data (- rev 1)))))
  165.  
  166. (define (port-revealed port)
  167.   (let ((count (fdport-data:revealed
  168.         (extensible-port-local-data
  169.          (check-arg fdport? port port-revealed)))))
  170.     (and (not (zero? count)) count)))
  171.  
  172. (define (fdes->port fd port-maker) ; local proc.
  173.   (let ((port (or (%maybe-fdes->port fd)
  174.           (let ((port (port-maker fd)))
  175.             (%install-port fd port)
  176.             port))))
  177.     (increment-revealed-count port 1)
  178.     port))
  179.  
  180. (define (fdes->inport fd)  (fdes->port fd make-input-fdport))
  181. (define (fdes->outport fd) (fdes->port fd make-output-fdport))
  182.  
  183. (define (port->fdes port)
  184.   (check-arg open-fdport? port port->fdes)
  185.   (let ((data (extensible-port-local-data port)))
  186.     (increment-revealed-count port 1)
  187.     (fdport-data:fd data)))
  188.  
  189. (define (call/fdes fd/port proc)
  190.   (cond ((integer? fd/port)
  191.      (proc fd/port))
  192.  
  193.     ((fdport? fd/port)
  194.      (let ((port fd/port))
  195.        (dynamic-wind
  196.         (lambda ()
  197.           (if (not port) (error "Can't throw back into call/fdes.")))
  198.         (lambda () (proc (port->fdes port)))
  199.         (lambda ()
  200.           (release-port-handle port)
  201.           (set! port #f)))))
  202.  
  203.     (else (error "Not a file descriptor or fdport." fd/port))))
  204.  
  205.  
  206. ;;; Random predicates and arg checkers
  207. ;;; ----------------------------------
  208.  
  209. (define (open-fdport-data? x)
  210.   (and (fdport-data? x)
  211.        (not (fdport-data:closed? x))))
  212.  
  213. (define (open-fdport? x)
  214.   (cond ((or (and (extensible-input-port?  x)
  215.           (extensible-input-port-local-data  x))
  216.          (and (extensible-output-port? x)
  217.           (extensible-output-port-local-data x)))
  218.      => (lambda (d) (and (fdport-data? d) (not (fdport-data:closed? d)))))
  219.     (else #f)))
  220.  
  221. (define (extensible-port-local-data xport)
  222.   ((if (extensible-input-port? xport)
  223.        extensible-input-port-local-data
  224.        extensible-output-port-local-data)
  225.    xport))
  226.  
  227. (define (fdport-open? port)
  228.   (check-arg fdport? port fdport-open?)
  229.   (not (fdport-data:closed? (extensible-port-local-data port))))
  230.  
  231.  
  232. ;;; Initialise the system
  233. ;;; ---------------------
  234.  
  235. (define old-inport #f)    ; Just because.
  236. (define old-outport #f)
  237. (define old-errport #f)
  238.  
  239. (define (init-fdports!)
  240.   (%init-fdports!)
  241.   (if (not (fdport? (current-input-port)))
  242.       (set! old-inport (current-input-port)))
  243.   (if (not (fdport? (current-output-port)))
  244.       (set! old-outport (current-output-port)))
  245.   (if (not (fdport? (error-output-port)))
  246.       (set! old-errport (error-output-port)))
  247.   (let ((iport (fdes->inport  0)))
  248.     (set-port-buffering iport bufpol/none)    ; Stdin is unbuffered.
  249.     (set-fluid! $current-input-port  iport)
  250.     (set-fluid! $current-output-port (fdes->outport 1))
  251.     (set-fluid! $error-output-port   (fdes->outport 2))))
  252.  
  253.  
  254. ;;; Generic port operations
  255. ;;; -----------------------
  256.  
  257. ;;; (close-after port f)
  258. ;;;     Apply F to PORT. When F returns, close PORT, then return F's result.
  259. ;;;     Does nothing special if you throw out or throw in.
  260.  
  261. (define (close-after port f)
  262.   (receive vals (f port)
  263.     (close port)
  264.     (apply values vals)))
  265.  
  266. (define (close port/fd)
  267.   ((cond ((integer? port/fd)      close-fdes)
  268.      ((output-port? port/fd) close-output-port)
  269.      ((input-port?  port/fd) close-input-port)
  270.      (else (error "Not file-descriptor or port" port/fd)))    port/fd))
  271.  
  272. ;;; If this fd has an associated input or output port,
  273. ;;; move it to a new fd, freeing this one up.
  274. ;;; Unitialized fdport in table is set to 0, does this mean
  275. (define (evict-ports fd)
  276.   (cond ((%maybe-fdes->port fd) =>    ; Shouldn't bump the revealed count.
  277.          (lambda (port) 
  278.        (%move-fdport (%dup fd) port 0)))))
  279.  
  280. (define (close-fdes fd)
  281.   (evict-ports fd)
  282.   (%close-fdes fd))
  283.  
  284.  
  285. ;;; Extend R4RS i/o ops to handle file descriptors.
  286. ;;; -----------------------------------------------
  287.  
  288. (define s48-char-ready? (structure-ref scheme char-ready?))
  289. (define s48-read-char   (structure-ref scheme read-char))
  290.  
  291. (define-simple-syntax
  292.   (define-r4rs-input (name arg ...) stream s48name body ...)
  293.   (define (name arg ... . maybe-i/o)
  294.     (let ((stream (optional-arg maybe-i/o (current-input-port))))
  295.       (cond ((input-port? stream) (s48name arg ... stream))
  296.         ((integer? stream) body ...)
  297.         (else (error "Not a port or file descriptor" stream))))))
  298.  
  299. (define-r4rs-input (char-ready?) input s48-char-ready?
  300.   (%char-ready-fdes? input))
  301.  
  302. (define-r4rs-input (read-char) input s48-read-char
  303.   (read-fdes-char input))
  304.  
  305. ;structure refs changed to get reference from scheme -dalbertz
  306. (define s48-display    (structure-ref scheme display))
  307. (define s48-newline    (structure-ref scheme newline))
  308. (define s48-write      (structure-ref scheme write))
  309. (define s48-write-char (structure-ref scheme write-char))
  310. (define s48-format     (structure-ref formats format))
  311. (define s48-force-output (structure-ref ports force-output))
  312.  
  313. (define-simple-syntax
  314.   (define-r4rs-output (name arg ...) stream s48name body ...)
  315.   (define (name arg ... . maybe-i/o)
  316.     (let ((stream (optional-arg maybe-i/o (current-output-port))))
  317.       (cond ((output-port? stream) (s48name arg ... stream))
  318.         ((integer? stream) body ...)
  319.         (else (error "Not a port or file descriptor" stream))))))
  320.  
  321. ;;; This one depends upon S48's string ports.
  322. (define-r4rs-output (display object) output s48-display
  323.   (let ((sp (make-string-output-port)))
  324.     (display object sp)
  325.     (write-string (string-output-port-output sp) output)))
  326.  
  327. (define-r4rs-output (newline) output s48-newline
  328.   (write-fdes-char #\newline output))
  329.  
  330. (define-r4rs-output (write object) output s48-write
  331.   (let ((sp (make-string-output-port)))
  332.     (write object sp)
  333.     (write-string (string-output-port-output sp) output)))
  334.  
  335. (define-r4rs-output (write-char char) output s48-write-char
  336.   (write-fdes-char char output))
  337.  
  338. ;;; S48's force-output doesn't default to forcing (current-output-port). 
  339. (define-r4rs-output (force-output) output s48-force-output
  340.   (values)) ; Do nothing if applied to a file descriptor.
  341.  
  342.  
  343. (define (format dest cstring . args)
  344.   (if (integer? dest)
  345.       (write-string (apply s48-format #f cstring args) dest)
  346.       (apply s48-format dest cstring args)))
  347.  
  348. ;;; with-current-foo-port procs
  349. ;;; ---------------------------
  350.  
  351. (define (with-current-input-port* port thunk)
  352.   (let-fluid $current-input-port port thunk))
  353.  
  354. (define (with-current-output-port* port thunk)
  355.   (let-fluid $current-output-port port thunk))
  356.  
  357. (define (with-error-output-port* port thunk)
  358.   (let-fluid $error-output-port port thunk))
  359.  
  360. (define-simple-syntax (with-current-input-port port body ...)
  361.   (with-current-input-port* port (lambda () body ...)))
  362.  
  363. (define-simple-syntax (with-current-output-port port body ...)
  364.   (with-current-output-port* port (lambda () body ...)))
  365.  
  366. (define-simple-syntax (with-error-output-port port body ...)
  367.   (with-error-output-port* port (lambda () body ...)))
  368.  
  369.  
  370. ;;; set-foo-port! procs
  371. ;;; -------------------
  372. ;;; Side-effecting variants of with-current-input-port* and friends.
  373.  
  374. (define (set-current-input-port!  port) (set-fluid! $current-input-port  port))
  375. (define (set-current-output-port! port) (set-fluid! $current-output-port port))
  376. (define (set-error-output-port!   port) (set-fluid! $error-output-port   port))
  377.  
  378.  
  379. ;;; call-with-foo-file with-foo-to-file
  380. ;;; -----------------------------------
  381.  
  382. ;;; Copied straight from rts/port.scm, but re-defined in this module,
  383. ;;; closed over my versions of open-input-file and open-output-file.
  384.  
  385. (define (call-with-mumble-file open close)
  386.   (lambda (string proc)
  387.     (let ((port #f))
  388.       (dynamic-wind (lambda ()
  389.               (if port
  390.               (warn "throwing back into a call-with-...put-file"
  391.                 string)
  392.               (set! port (open string))))
  393.             (lambda () (proc port))
  394.             (lambda ()
  395.               (if port
  396.               (close port)))))))
  397.  
  398. (define call-with-input-file
  399.   (call-with-mumble-file open-input-file close-input-port))
  400.  
  401. (define call-with-output-file
  402.   (call-with-mumble-file open-output-file close-output-port))
  403.  
  404. (define (with-input-from-file string thunk)
  405.   (call-with-input-file string
  406.     (lambda (port)
  407.       (let-fluid $current-input-port port thunk))))
  408.  
  409. (define (with-output-to-file string thunk)
  410.   (call-with-output-file string
  411.     (lambda (port)
  412.       (let-fluid $current-output-port port thunk))))
  413.